perm filename INDEX[LSP,LSP]2 blob
sn#336601 filedate 1978-02-18 generic text, type T, neo UTF8
00100 (COMMENT This file contains two versions of the index
00200 program The first runs faster than the second by
00300 attaching to each entry in the list to be sorted
00400 a key derived from the appropriate PNAME The
00500 second would probably be as fast if suitable
00600 privitives were hand coded It is a simpler
00700 structure and is ammenable to some improvement
00800 in format in the case where various objects of
00900 different types have the same name)
01000
01100 (DECLARE (SPECIAL FILENAME FUNLIST PAGELINE STIME)
01200 (SPECIAL BASE *NOPOINT))
01300
01400 (DE ADDTOFUNLIST (NAME TYPE)
01500 (SETQ FUNLIST (MERGE (MKENTRY NAME
01600 TYPE
01700 (CONS FILENAME PAGELINE))
01800 FUNLIST)))
01900
02000 (DE ALPHLESS (AT1 AT2)
02100 (PNAMELESS (GET AT1 (QUOTE PNAME))
02200 (GET AT2 (QUOTE PNAME))))
02300
02400 (DE ATTACHKEY (LIST) (CONS (MKKEY LIST) LIST))
02500
02600 (DE CURCOL NIL (*DIF (ADD1 (LINELENGTH NIL)) (CHRCT)))
02700
03100 (DE DEDFDMAUX (ARG2 TYPE)
03200 (ADDTOFUNLIST (COND ((ATOM ARG2) ARG2) (T (CAR ARG2)))
03300 TYPE))
03400
00100 (DEFPROP INDEX
00200 (LAMBDA (FILES)
00300 (PROG (EXPR FILENAME FUNLIST INDEV OUTDEV OUTFILE
00400 PAGELINE STIME)
00500 (SETQ INDEV (QUOTE DSK:))
00600 (SETQ OUTDEV (QUOTE DSK:))
00700 OLOOP(COND ((NULL FILES)
00800 (PRINTINDEX OUTDEV OUTFILE FUNLIST)
00900 (RETURN NIL)))
01000 (COND ((ISINPUT (CAR FILES)) (GO IN))
01100 ((ISOUTPUT (CAR FILES)) (GO OUT)))
01200 (INC (EVAL (LIST (QUOTE INPUT)
01300 INDEV
01400 (CAR FILES)))
01500 NIL)
01600 (SETQ FILENAME (CAR FILES))
01700 (SETQ STIME (TIME))
01800 ILOOP(SETQ EXPR (ERRSET (NEWREAD)))
01900 (COND ((EQ EXPR (QUOTE $EOF$)) (GO ELOOP)))
02000 (PROCESSEXPR (CAR EXPR))
02100 (GO ILOOP)
02200 ELOOP(INC NIL T)
02300 (SETQ FILES (CDR FILES))
02400 (GO OLOOP)
02500 IN (SETQ INDEV (CAR FILES))
02600 (GO ELOOP)
02700 OUT (PRINTINDEX OUTDEV OUTFILE FUNLIST)
02800 (SETQ OUTFILE (COND ((NULL (CDAR FILES))
02900 (CAAR FILES))
03000 (T (CADAR FILES))))
03100 (COND ((NOT (NULL (CDAR FILES)))
03200 (SETQ OUTDEV (CAAR FILES))))
03300 (GO ELOOP)))
03400 FEXPR)
03500
03600 (DE INDEXDE (EXPR)
03700 (DEDFDMAUX (CADR EXPR) (QUOTE EXPR)))
03800
03900 (DE INDEXDECLARE (EXPR)
04000 (MAPC (FUNCTION PROCESSEXPR) (CDR EXPR)))
04100
04200 (DE INDEXDEFPROP (EXPR)
04300 (COND ((GET (CADDDR EXPR) (QUOTE INDTYPE))
04400 (ADDTOFUNLIST (CADR EXPR) (CADDDR EXPR)))))
04500
04600 (DE INDEXDEFUN (EXPR)
04700 (PROG (LEN)
04800 (SETQ LEN (LENGTH EXPR))
04900 (COND ((EQUAL LEN 4)
05000 (ADDTOFUNLIST (CADR EXPR) (QUOTE EXPR))
05100 (RETURN NIL)))
05200 (ADDTOFUNLIST (CADR EXPR) (CADDR EXPR))))
05300
05400 (DE INDEXDF (EXPR)
05500 (DEDFDMAUX (CADR EXPR) (QUOTE FEXPR)))
05600
05700 (DE INDEXDFUNC (EXPR)
05800 (ADDTOFUNLIST (CAADR EXPR) (QUOTE EXPR)))
05900
00100 (DE INDEXDM (EXPR)
00200 (DEDFDMAUX (CADR EXPR) (QUOTE MACRO)))
00300
00400 (DE INDEXLAP (EXPR)
00500 (COND ((GET (CADDR EXPR) (QUOTE INDTYPE))
00600 (ADDTOFUNLIST (CADR EXPR) (CADDR EXPR)))))
00700
00800 (DE INDEXSETQ (EXPR)
00900 (ADDTOFUNLIST (CADR EXPR) (QUOTE VALUE)))
01000
01100 (DE INDEXSPECIAL (EXPR)
01200 (PROG (VARS)
01300 (SETQ VARS (CDR EXPR))
01400 LOOP (COND ((NULL VARS) (RETURN NIL)))
01500 (ADDTOFUNLIST (CAR VARS) (QUOTE SPECIAL))
01600 (SETQ VARS (CDR VARS))
01700 (GO LOOP)))
01800
01900 (DE ISAREA (EXPR)
02000 (AND (NOT (ATOM EXPR))
02100 (NOT (ATOM (CDR EXPR)))
02200 (NOT (ISDEV (CAR EXPR)))))
02300
02400 (DE ISDEV (EXPR)
02500 (AND (ATOM EXPR)
02600 (EQ (CAR (LAST (EXPLODE EXPR))) (QUOTE :))))
02700
02800 (DE ISFILE (EXPR)
02900 (OR (AND (ATOM EXPR) (NOT (ISDEV EXPR)))
03000 (AND (NOT (ATOM EXPR)) (ATOM (CDR EXPR)))))
03100
03200 (DE ISINPUT (EXPR) (OR (ISDEV EXPR) (ISAREA EXPR)))
03300
03400 (DE ISLESS (L1 L2)
03500 (COND (USEKEY (KEYLESS L1 L2)) (T (ALPHALESS L1 L2))))
03600
03700 (DE ISOUTPUT (EXPR)
03800 (AND (NOT (ATOM EXPR))
03900 (OR (AND (NULL (CDR EXPR)) (ISFILE (CAR EXPR)))
04000 (AND (NOT (ATOM (CDR EXPR)))
04100 (ISDEV (CAR EXPR))))))
04200
04300 (DE KEYLESS (L1 L2)
04400 (COND ((LESSP (CAR L1) (CAR L2)) T)
04500 ((LESSP (CAR L2) (CAR L1)) NIL)
04600 (T (KEYLESSL (CDR L1) (CDR L2)))))
04700
04800 (DE KEYLESSL (L1 L2)
04900 (COND ((NULL L1) T)
05000 ((NULL L2) NIL)
05100 (T (KEYLESS L1 L2))))
05200
05300 (DE LINEF (N)
05400 (PROG NIL
05500 LOOP (COND ((ZEROP N) (RETURN NIL)))
05600 (TERPRI)
05700 (SETQ N (SUB1 N))
05800 (GO LOOP)))
05900
00100 (DE MERGE (ELEM LIST)
00200 (PROG (TEM)
00300 (SETQ TEM LIST)
00400 LOOP (COND ((NULL TEM) (RETURN (LIST ELEM))))
00500 (COND ((ISLESS (CAR ELEM) (CAAR TEM))
00600 (RPLACA (RPLACD TEM
00700 (CONS (CAR TEM) (CDR TEM)))
00800 ELEM)
00900 (RETURN LIST)))
01000 (COND ((NULL (CDR TEM)) (NCONC TEM (LIST ELEM))
01100 (RETURN LIST)))
01200 (SETQ TEM (CDR TEM))
01300 (GO LOOP)))
01400
01500 (DE MKENTRY (NAME TYPE LOC)
01600 (COND (USEKEY (ATTACHKEY (LIST NAME TYPE LOC)))
01700 (T (LIST NAME TYPE LOC))))
01800
01900 (DE MKKEY (ITEM)
02000 (PROG (PNAME KEY)
02100 (SETQ PNAME (GET (CAR ITEM) (QUOTE PNAME)))
02200 LOOP (COND ((NULL PNAME) (RETURN (REVERSE KEY))))
02300 (SETQ KEY (CONS (EXAMINE (MAKNUM (CAR PNAME)
02400 (QUOTE FIXNUM)))
02500 KEY))
02600 (SETQ PNAME (CDR PNAME))
02700 (GO LOOP)))
02800
02900 (DE NEWREAD NIL
03000 (PROG NIL
03100 LOOP (COND ((MEMQ (NEXTTYI) (QUOTE (11 12 14 15 40)))
03200 (TYI)
03300 (GO LOOP)))
03400 (SETQ PAGELINE (PGLINE))
03500 (RETURN (READ))))
03600
03601 (DE NONKEYPART (ENTRY)
03634 (COND (USEKEY (CDR ENTRY)) (T ENTRY)))
03667
03700 (DEFSYM (QUOTE TYI) 1027)
03800
03900 (DEFSYM (QUOTE OLDCH) 1112)
04000
04100 (LAP NEXTTYI SUBR)
04200 (PUSHJ P TYI)
04300 (MOVEM 1 OLDCH)
04400 (JRST 0 FIX1A)
04500 NIL
04600
04700 (DE PNAMELESS (L1 L2)
04800 ((LAMBDA (W1 W2)
04900 (COND ((LESSP W1 W2) T)
05000 ((LESSP W2 W1) NIL)
05100 (T (PNAMELESSL (CDR L1) (CDR L2)))))
05200 (EXAMINE (MAKNUM (CAR L1) (QUOTE FIXNUM)))
05300 (EXAMINE (MAKNUM (CAR L2) (QUOTE FIXNUM)))))
05400
05500 (DE PNAMELESSL (L1 L2)
05600 (COND ((NULL L1) T)
05700 ((NULL L2) NIL)
05800 (T (PNAMELESS L1 L2))))
05900
06000 (DE PRINL (L) (MAPC (FUNCTION PRINS) L))
06100
00100 (DE PRINS (EXP) (PROG2 (PRIN1 EXP) (PRINC (ASCII 40))))
00200
00300 (DE PRINTHEADING NIL
00400 (PROG NIL
00500 (PRIN1 (QUOTE NAME))
00600 (TABTO 30)
00700 (PRIN1 (QUOTE TYPE))
00800 (TABTO 50)
00900 (PRIN1 (QUOTE FILE))
01000 (TABTO 70)
01100 (PRIN1 (QUOTE PAGE))
01200 (TABTO 100)
01300 (PRIN1 (QUOTE LINE))
01400 (LINEF 3)))
01500
01600 (DE PRINTENTRY (DATUM)
01700 (PROG NIL
01800 (PRIN1 (CAR DATUM))
01900 (TABTO 30)
02000 (PRIN1 (CADR DATUM))
02100 (TABTO 50)
02200 (COND ((ATOM (CAR (CADDR DATUM)))
02300 (PRIN1 (CAR (CADDR DATUM))))
02400 (T (PRIN1 (CAR (CAR (CADDR DATUM))))
02500 (PRINC (ASCII 56))
02600 (PRIN1 (CDR (CAR (CADDR DATUM))))))
02700 (TABTO 70)
02800 (PRIN1 (CADR (CADDR DATUM)))
02900 (TABTO 100)
03000 (PRIN1 (CDDR (CADDR DATUM)))
03100 (LINEF 1)))
03200
03300 (DE PRINTINDEX (DEV FILE DATA)
03400 (PROG (*NOPOINT BASE COUNT)
03500 (SETQ COUNT 0)
03600 (COND ((NULL DATA) (RETURN NIL)))
03700 (COND ((NOT (NULL FILE))
03800 (OUTC (EVAL (LIST (QUOTE OUTPUT) DEV FILE))
03900 NIL)))
04000 (SETQ BASE (PLUS 5 5))
04100 (SETQ *NOPOINT T)
04200 (PRINTHEADING)
04300 LOOP (COND ((NULL DATA) (GO EXIT)))
04400 (PRINTENTRY (NONKEYPART (CAR DATA)))
04500 (SETQ DATA (CDR DATA))
04600 (SETQ COUNT (ADD1 COUNT))
04700 (GO LOOP)
04800 EXIT (OUTC NIL T)
04900 (PRINT COUNT)
05000 (PRINL (QUOTE (ENTRIES IN INDEX)))
05100 (PRINS (ADD1 (QUOTIENT (*DIF (TIME) STIME) 1750)))
05200 (PRINS (QUOTE SECONDS))))
05300
05400 (DE PRINTN (CHAR NUM)
05500 (PROG (NO)
05600 (SETQ NO 1)
05700 LOOP (COND ((LESSP NUM NO) (RETURN NUM)))
05800 (PRINC CHAR)
05900 (SETQ NO (ADD1 NO))
06000 (GO LOOP)))
06100
00100 (DE PROCESSEXPR (EXPR)
00200 (PROG (PROP)
00300 (COND ((ATOM EXPR) (RETURN NIL)))
00400 (SETQ PROP (GETL (CAR EXPR) (QUOTE (INDFUN))))
00500 (COND ((NULL PROP) (RETURN NIL)))
00600 ((CADR PROP) EXPR)))
00700
00800 (DE TABTO (COLUMN)
00900 (PROG NIL
01000 (COND ((GREATERP (CURCOL) COLUMN) (LINEF 1)))
01100 (PRINTN (ASCII 11)
01200 (*DIF (LSH (SUB1 COLUMN) -3)
01300 (LSH (SUB1 (CURCOL)) -3)))
01400 (PRINTN (ASCII 40) (*DIF COLUMN (CURCOL)))))
01500
01600 (DEFPROP DE INDEXDE INDFUN)
01700
01800 (DEFPROP DECLARE INDEXDECLARE INDFUN)
01900
02000 (DEFPROP DEFPROP INDEXDEFPROP INDFUN)
02100
02200 (DEFPROP DEFUN INDEXDEFUN INDFUN)
02300
02400 (DEFPROP DF INDEXDF INDFUN)
02500
02600 (DEFPROP DFUNC INDEXDFUNC INDFUN)
02700
02800 (DEFPROP DM INDEXDM INDFUN)
02900
03000 (DEFPROP LAP INDEXLAP INDFUN)
03100
03200 (DEFPROP SETQ INDEXSETQ INDFUN)
03300
03400 (DEFPROP SPECIAL INDEXSPECIAL INDFUN)
03500
03600 (DEFPROP EXPR T INDTYPE)
03700
03800 (DEFPROP FEXPR T INDTYPE)
03900
04000 (DEFPROP SUBR T INDTYPE)
04100
04200 (DEFPROP FSUBR T INDTYPE)
04300
04400 (DEFPROP LSUBR T INDTYPE)
04500
04600 (DEFPROP MACRO T INDTYPE)
04700
04800 (DEFPROP SPECIAL T INDTYPE)
04900
05000 (DEFPROP VALUE T INDTYPE)
05100
05200 (SETQ USEKEY T)
05300